(FILECREATED "12-NOV-75 04:39:19" <LENAT>SPARE.;2 8863   

     previous date: "12-NOV-75 02:16:46" <LENAT>SPARE.;1)


  (LISPXPRINT (QUOTE SPARECOMS)
	      T T)
  [RPAQQ SPARECOMS
	 ((FNS ACEX-OLD ALLQ CLEAN CLEANALL COM-ANCES DIE FAN FRAC-INCLU FRIPPLE GCB GET-TIME GEXEC INIT-PART JUST-ONCE 
	       LESS-INT LRU-TAG MAX MAX1 MORE-GENERAL MORE-INT MORE-SPECIFIC NO-COMMEN ONLY-COMS PUTU RE-JUDGE 
	       READ-LOOP READ1CHAR RIPPLE-SIMULT RIPPLE1 RUN-COMM-IF-MUST SAME-TYPE SATISFIES SEQX SETBINT SETBINT 
	       SUB-CANDS SWAPB SWGETB SWSETB UNDO-INIT XEQ-CLEAN XTR-BEING)
	  (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
										(NLAML RE-JUDGE JUST-ONCE ALLQ]
(DEFINEQ

(ACEX-OLD
  [LAMBDA (B)
    (OR [RUN-COMM-IF-MUST (XTR-AC-EX (GETB B (QUOTE EXS]
	(RUN-COMM-IF-MUST (XTR-AC-EX (APPLY* (QUOTE EXS)
					     B])

(ALLQ
  [NLAMBDA (L)
    (COND
      ((NLISTP L)
	(KWOTE L))
      ((CONS (QUOTE LIST)
	     (MAPCAR L (QUOTE ALLQ])

(CLEAN
  [LAMBDA (P1 P2 P1I P2I)
    (SETQ P2I (GETB (GLUE (QUOTE ANYB)
			  P2)
		    (QUOTE INIT)))
    (MAPC CONCEPTS (FUNCTION (LAMBDA (C)
	      (MAPC (GETB C P1)
		    (FUNCTION (LAMBDA (B)
			(AND (IS-CON B)
			     (PUT B P2 (APPEND P2I (UNION (LIST C)
							  (GETB B P2])

(CLEANALL
  [LAMBDA NIL
    (CLEAN (QUOTE SPEC)
	   (QUOTE GENL))
    (CLEAN (QUOTE GENL)
	   (QUOTE SPEC))
    (CLEAN (QUOTE UP)
	   (QUOTE EXS])

(COM-ANCES
  [LAMBDA (B1 B2)
    (INTERSECTION (RIPPLE B1 (QUOTE GENL))
		  (RIPPLE B2 (QUOTE GENL])

(DIE
  [LAMBDA (MES)
    (CPRIN1S -1 CRLF CRLF *********** AM FATAL COLLAPSE *********** CRLF MES CRLF CRLF)
    (HELP])

(FAN
  [LAMBDA (MSET MPAR MB1)
    (CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
			   (APPLYB MS1 MPAR MB1])

(FRAC-INCLU
  [LAMBDA (B1 B2)
    (COND
      ((EQ B1 B2)
	100)
      ((ISA B1 B2)
	99)
      ((ISA B2 B1)
	50)
      (T                                                                        (* NOTICE HOW CRUDE THIS IS.
										IMPROVE IT!!)
	 0])

(FRIPPLE
  [LAMBDA (RB)
    (CONS RB (MAPCONC (GETB RB P)
		      (QUOTE FRIPPLE])

(GCB
  [LAMBDA (N)
    [MAPC ONCE-LIST (FUNCTION (LAMBDA (C)
	      (SETB (CAR C)
		    (CDR C)
		    (REMOVE JTRASH (GETB (CAR C)
					 (CDR C]
    (SETQ ONCE-LIST INIT-ONCE-LIST)
    (FOR GCX IN (SORT (COPY CONCEPTS)
		      (QUOTE GET-TIME))
       AS GCI FROM 1 TO N DO (SWAPB GCX])

(GET-TIME
  [LAMBDA (B)
    (GETU B (QUOTE TIME])

(GEXEC
  [LAMBDA (GB)
    (APPLYB GB GPNAME])

(INIT-PART
  [LAMBDA (B P)
    (OR (GETP B P)
	(SETB B P NIL])

(JUST-ONCE
  [NLAMBDA (X X1)
    (COND
      ((SETQ X1 (EVAL X))
	(FRPLACA X (QUOTE COND))
	(FRPLACD X NIL)
	X1])

(LESS-INT
  [LAMBDA (A B)
    (ILESSP (CAR A)
	    (CAR B])

(LRU-TAG
  [LAMBDA (B)
    (PUTU B (QUOTE TIME)
	  (IQUOTIENT (CLOCK 2)
		     10000])

(MAX
  [LAMBDA (MSET MPAR)
    (COND
      [MSET (CAR (SORT (MAPCAR MSET MPAR]
      (T -1])

(MAX1
  [LAMBDA (MSET MPAR MB1)
    (CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
			   (APPLYB MB1 MPAR MS1])

(MORE-GENERAL
  [LAMBDA (B1 B2)
    (COND
      ((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
	B2)
      ((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
	B1)
      (T NIL])

(MORE-INT
  [LAMBDA (A B)
    (IGREATERP (CINT A)
	       (CINT B])

(MORE-SPECIFIC
  [LAMBDA (B1 B2)
    (COND
      ((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
	B1)
      ((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
	B2)
      (T NIL])

(NO-COMMEN
  [LAMBDA (X)
    (OR (NLISTP X)
	(NEQ (CAR X)
	     (QUOTE COMMENT])

(ONLY-COMS
  [LAMBDA (L)
    (EVERY L (FUNCTION (LAMBDA (L1)
	       (EQ (CAR L1)
		   (QUOTE COMMENT])

(PUTU
  [LAMBDA (B PROP PVAL)
    (COND
      ((CAR (ERRORSET B))
	(PUTL (EVAL B)
	      PROP PVAL))
      (T (SET B (LIST PROP PVAL])

(RE-JUDGE
  [NLAMBDA (RJ I1)
    (CPRIN1S 8 SUPPOSED TO RE-JUDGE RJ CRLF)
    (AND [SETQ I1 (ERSETQ (APPLY* (CAR RJ)
				  (QUOTE C-INT)
				  (EVAL RJ]
	 (NUMBERP I1)
	 (IGREATERP I1 EX-THRESH)
	 (CREATEB RJ])

(READ-LOOP
  [LAMBDA NIL
    (PROG NIL
      L11 (COND
	    ((READP))
	    (T (DISMISS 1000)
	       (GO L11])

(READ1CHAR
  [LAMBDA NIL
    (READ-LOOP)
    (CLEARBUF T T)
    (SETQ GPEEK (SYSBUF T))
    (SETQ GPEEK1 (GNC GPEEK))
    (OR GPEEK1 (READ1CHAR))                                                     (* OR (STREQUAL GPEEK "") 
										(BKSYSBUF GPEEK))
										(* AND (SETQ GS (LINBUF T)) 
										(BKLINBUF GS))
    GPEEK1])

(RIPPLE-SIMULT
  [LAMBDA (ATYPE DIRS)
    (COND
      ((CDR DIRS)
	(PROG ((NEW (LIST ATYPE))
	       (OLD (LIST ATYPE)))
	  L1  [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
					 (MAPCONC DIRS (FUNCTION (LAMBDA (XTR-PART)
						      (MAPCONC (GETB AL1 XTR-PART)
							       (QUOTE XTR-BEING]
	      (SETQ OLD (INTERSECTION OLD OLD))
	      (AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
		   (RETURN NEW))
	      (GO L1)))
      (DIRS (RIPPLE ATYPE (CAR DIRS)))
      ((LIST ATYPE])

(RIPPLE1
  [LAMBDA (B4 P4 DIR RTEMP)
    (COND
      ((LISTP B4)
	(SETQ GXTR-PART P4)
	[SOME (XTR-BEING B4)
	      (FUNCTION (LAMBDA (B5)
		  (SETQ RTEM2 (RIPPLE1 B5 P4 DIR]
	RTEM2)
      ((GETHASH (SETQ RTEMP (GLUE B4 P4))
		HCON)
	RTEMP)
      ((GETHASH B4 HCON)
	(RIPPLE1 (GETB B4 DIR)
		 P4 DIR])

(RUN-COMM-IF-MUST
  [LAMBDA (L)
    (COND
      ((NLISTP L)
	L)
      ((SUBSET L (QUOTE NLISTP)))
      [(MAPCAR [SUBSET L (FUNCTION (LAMBDA (X)
			   (EQ (CAR X)
			       (QUOTE OR-RUN:]
	       (FUNCTION (LAMBDA (Z)
		   (EVAL (CADR Z]
      [(SUBSET L (FUNCTION (LAMBDA (X)
		   (NEQ (CAR X)
			(QUOTE COMMENT]
      (T (SETQ CS-FAIL T)
	 (ADD-CANDS (LIST (LIST CS-INT (QUOTE FILLIN)
				Z
				(QUOTE EXS))
			  (LIST (SUB1 CS-INT)
				(QUOTE FILLIN)
				CS-B CS-P)))
	 NIL])

(SAME-TYPE
  [LAMBDA (B1 B2 BTYP)
    (OR (AND (EQ B1 BTYP)
	     (EQ B2 B1)
	     B1)
	(CADR (MEMB BTYP (COM-ANCES B1 B2])

(SATISFIES
  [LAMBDA NIL NIL])

(SEQX
  [LAMBDA (X1)
    (OR (EQUAL X1 (CAR X))
	(APPLYB (QUOTE STRUCTURE-EQUAL)
		(QUOTE ALGS)
		(APPEND (CAR X))
		(APPEND X1])

(SETBINT
  [LAMBDA (C X)
    (RPLACA (CDR C)
	    X])

(SETBINT
  [LAMBDA (C X)
    (RPLACA (CDR C)
	    X])

(SUB-CANDS
  [LAMBDA (SL)
    [MAPC SL (FUNCTION (LAMBDA (S)
	      (SOME CANDS (FUNCTION (LAMBDA (C)
			(AND (EQUAL (CACT C)
				    (CACT S))
			     (RPLACA C (IQUOTIENT (CINT C)
						  2]                            (* This is rather an inefficient way to 
										do this.)
    CANDS])

(SWAPB
  [LAMBDA (B PFILE)
    (COND
      ((GETU B (QUOTE FOUT)))
      ((PUTU B (QUOTE FOUT)
	     (LIST (SETQ PFILE (GETPROPERFILE))
		   (GETPROPERFILEPOS)))
	(PRIN2 (GETPROPLIST B)
	       PFILE)))
    (COND
      ((FMEMB B NOSWAP-CONCEPTS))
      ((SETPROPLIST B 0])

(SWGETB
  [LAMBDA (B P F)
    (LRU-TAG B)
    (COND
      ((GET B P))
      ((ZEROP (GETPROPLIST B))
	(SETQ F (GETU B (QUOTE FOUT)))
	[COND
	  ((ATOM F)
	    (LOADVARS (LIST (LIST (QUOTE (QUOTE PUTPROPS))
				  (KWOTE B)
				  (QUOTE $)))
		      F T))
	  (T (SETFILEPTR (CAR F)
			 (CADR F]
	(SETQ B (READ (CAR F)))
	(GET B P])

(SWSETB
  [LAMBDA (B P Q BP)
    (AND (FMEMB P XEQ-PARTS)
	 (PUTD (SETQ BP (GLUEE B P))
	       (LIST (QUOTE LAMBDA)
		     (GETARGS P)
		     (LIST (QUOTE SELF-COMPILE)
			   BP Q)))
	 (NOT (GETB B P))
	 (ATTACH (NCONC (LIST P (LIST BP))
			(GETARGS P))
		 (BPFS B)))
    (AND (GETU B (QUOTE FOUT))
	 (PUTU B (QUOTE FOUT)
	       NIL))
    (LRU-TAG B)
    (PUT B P Q])

(UNDO-INIT
  [LAMBDA (P L)                                                                 (* Old value was: (COND 
										((GETHASH P HUND) (APPLY* 
										(GETP P (QUOTE UNDO-INIT)) L)) 
										(L)))
    L])

(XEQ-CLEAN
  [LAMBDA (B B1 B2 B3)
    (MATCH (DREVERSE (UNPACK B)) WITH (B2←$
					(QUOTE -)
					B1←$))
    (SETQ B1 (PACK (DREVERSE B1)))
    (SETQ B2 (PACK (DREVERSE B2)))
    (AND (FMEMB B2 FACETS)
	 (GETHASH B1 HCON)
	 NIL)                                                                   (* NOTNEEDED APPARENTLY.
										PERHAPS: in the function CREATEB)
    ])

(XTR-BEING
  [LAMBDA (B)                                                                   (* This actually will depend on the 
										format of the part being worked on.
										This part is to be assigned to the 
										variable XTR-PART)
    (COND
      ((ATOM B)
	(AND (GETHASH B HCON)
	     (LIST B)))
      ((LISTP B)
	(COND
	  ((EQUAL (CAR B)
		  (QUOTE OR-RUN:))
	    (EVAL (CADR B)))
	  (T (MAPCONC B (QUOTE XTR-BEING])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
  (ADDTOVAR NLAMA)
  (ADDTOVAR NLAML RE-JUDGE JUST-ONCE ALLQ)
]
(DECLARE: DONTCOPY
  (FILEMAP (NIL (716 8709 (ACEX-OLD 728 . 876) (ALLQ 880 . 1002) (CLEAN 1006 . 1298) (CLEANALL 1302 . 1455) (COM-ANCES
1459 . 1562) (DIE 1566 . 1689) (FAN 1693 . 1807) (FRAC-INCLU 1811 . 2072) (FRIPPLE 2076 . 2161) (GCB 2165 . 2461)
(GET-TIME 2465 . 2516) (GEXEC 2520 . 2567) (INIT-PART 2571 . 2636) (JUST-ONCE 2640 . 2759) (LESS-INT 2763 . 2825)
(LRU-TAG 2829 . 2919) (MAX 2923 . 3019) (MAX1 3023 . 3138) (MORE-GENERAL 3142 . 3299) (MORE-INT 3303 . 3373) (
MORE-SPECIFIC 3377 . 3535) (NO-COMMEN 3539 . 3623) (ONLY-COMS 3627 . 3734) (PUTU 3738 . 3878) (RE-JUDGE 3882 . 4100)
(READ-LOOP 4104 . 4220) (READ1CHAR 4224 . 4563) (RIPPLE-SIMULT 4567 . 5063) (RIPPLE1 5067 . 5381) (RUN-COMM-IF-MUST
5385 . 5885) (SAME-TYPE 5889 . 6017) (SATISFIES 6021 . 6052) (SEQX 6056 . 6191) (SETBINT 6195 . 6251) (SETBINT 6255
. 6311) (SUB-CANDS 6315 . 6616) (SWAPB 6620 . 6903) (SWGETB 6907 . 7251) (SWSETB 7255 . 7640) (UNDO-INIT 7644 . 7867)
(XEQ-CLEAN 7871 . 8252) (XTR-BEING 8256 . 8706)))))
STOP